Celestin Apprentice 4/Apprentice-Release4.iso/Languages/Oberon⁄F™ 1.1/Obx/Mod/BlackBox

Oberon Document | 1995-08-09 | 13.9 KB | 445 lines | [oODC/obnF]

Documents.StdDocumentDesc
Documents.DocumentDesc
Containers.ViewDesc
Views.ViewDesc
Stores.StoreDesc
Documents.ModelDesc
Containers.ModelDesc
Models.ModelDesc
Stores.ElemDesc
TextViews.StdViewDesc
TextViews.ViewDesc
TextModels.StdModelDesc
TextModels.ModelDesc
TextModels.AttributesDesc
Helvetica
Helvetica
Helvetica
MODULE ObxBlackBox;
    IMPORT Kernel, Ports, Stores, Models, Views, Controllers, Properties, Fonts, Dialog;
    CONST
        minded = -3; marked = -4; markedAndMinded = -7;    (* inside marks *)
        absorbed = -1; reflected = -2;    (* outside marks *)
        version = 0;
    TYPE
        Model = POINTER TO RECORD (Models.ModelDesc)
            board : POINTER TO ARRAY OF ARRAY OF SHORTINT;
            m, (* size of board *)
            p, (* number of atoms *)
            n, (* number of actual guess *)
            score: INTEGER;
            showsol: BOOLEAN;
        END;
        Path = POINTER TO RECORD
            i, j: INTEGER; next: Path
        END;
        View = POINTER TO RECORD (Views.ViewDesc)
            mod: Model;
            i, j: INTEGER;
            d: LONGINT;
            font: Fonts.Font
        END;
        UpdateMsg = RECORD (Models.UpdateMsg) END;
    VAR
        para*: RECORD
            nrOfAtoms*, boardSize*: INTEGER
        END;
        seed: LONGINT;
    PROCEDURE UniRand (): REAL;
        CONST a = 16807; m = 2147483647; q = m DIV a; r = m MOD a;
    BEGIN
        seed := a*(seed MOD q) - r*(seed DIV q);
        IF seed <= 0 THEN seed := seed + m END;
        RETURN seed * (1.0/m)
    END UniRand;
    (* problem-specific part *)
    PROCEDURE Atom (m: Model; i,j: INTEGER): BOOLEAN;
        VAR b: SHORTINT;
    BEGIN
        b := m.board[i,j]; RETURN (b = minded) OR (b = markedAndMinded)
    END Atom;
    PROCEDURE Marked (m: Model; i,j: INTEGER): BOOLEAN;
        VAR b: SHORTINT;
    BEGIN
        b := m.board[i,j]; RETURN (b = marked) OR (b = markedAndMinded)
    END Marked;
    PROCEDURE Shoot (m: Model; i1, j1: INTEGER);
        VAR i, j, d, di, dj : INTEGER;
    BEGIN
        IF j1 = 0 THEN di := 0; dj := 1
        ELSIF j1 = m.m+1 THEN di := 0; dj := -1
        ELSIF i1 = 0 THEN di := 1; dj := 0
        ELSIF i1 = m.m+1 THEN di := -1; dj := 0
        END;
        i := i1; j := j1;
        IF ~Atom(m, i+di, j+dj) THEN
            REPEAT
                IF Atom(m, i+di+dj, j+di+dj) THEN d := di; di := -dj; dj := -d
                ELSIF Atom(m,i+di-dj, j-di+dj) THEN d := di; di := dj; dj := d
                ELSE i := i+di; j := j+dj
                END
            UNTIL (i=0) OR (i=m.m+1) OR (j=0) OR (j=m.m+1) OR Atom(m, i+di, j+dj);
            IF (i=0) OR (i=m.m+1) OR (j=0) OR (j=m.m+1) THEN
                IF (i = i1) & (j = j1) THEN m.board[i1, j1] := reflected
                ELSE INC(m.n); m.board[i,j] := SHORT(m.n); m.board[i1,j1] := SHORT(m.n)
                END
            ELSE m.board[i1,j1] := absorbed
            END
        ELSE m.board[i1,j1] := absorbed
        END
    END Shoot;
    PROCEDURE GetPath (m: Model; i, j: INTEGER; VAR p: Path);
        VAR d, di, dj : INTEGER;
        PROCEDURE AddPoint(i, j: INTEGER);
            VAR q: Path;
        BEGIN
            IF (p = NIL) OR (p.i # i) OR (p.j # j) THEN NEW(q); q.i := i; q.j := j; q.next := p; p := q END
        END AddPoint;
    BEGIN
        IF j = 0 THEN di := 0; dj := 1
        ELSIF j = m.m+1 THEN di := 0; dj := -1
        ELSIF i = 0 THEN di := 1; dj := 0
        ELSIF i = m.m+1 THEN di := -1; dj := 0
        END;
        IF ~Atom(m, i+di, j+dj) THEN AddPoint(i, j);
            REPEAT
                IF Atom(m, i+di+dj, j+di+dj) THEN d := di; di := -dj; dj := -d; AddPoint(i, j)
                ELSIF Atom(m, i+di-dj, j-di+dj) THEN d := di; di := dj; dj := d; AddPoint(i, j)
                ELSE i := i+di; j := j+dj
                END;
            UNTIL (i = 0) OR (i = m.m+1) OR (j = 0) OR (j = m.m+1) OR Atom(m, i+di, j+dj);
            IF ~((i = 0) OR (i = m.m+1) OR (j = 0) OR (j = m.m+1)) THEN i := i+di; j := j+dj END;
            AddPoint(i, j)
        END
    END GetPath;
    PROCEDURE NewPuzzle (m: Model);
        VAR i, j, k: INTEGER;
    BEGIN
        FOR i := 0 TO m.m+1 DO FOR j := 0 TO m.m+1 DO m.board[i,j] := 0 END END;
        k := 0;
        WHILE k < m.p DO
            i := 1 + SHORT(ENTIER(UniRand()*m.m));
            j := 1 + SHORT(ENTIER(UniRand()*m.m));
            IF ~Atom(m, i, j) THEN m.board[i,j] := minded; INC(k) END
        END
    END NewPuzzle;
    PROCEDURE Score (m: Model): INTEGER;
        VAR i, j, score, n: INTEGER;
    BEGIN
        score := 0; n := 0;
        FOR i := 0 TO m.m + 1 DO
            FOR j := 0 TO m.m + 1 DO
                IF (i = 0) OR (j = 0) OR (i = m.m+1) OR (j = m.m+1) THEN
                    IF m.board[i,j] # 0 THEN INC(score) END
                ELSE
                    IF Marked(m, i, j) THEN INC(n);
                        IF ~Atom(m, i, j) THEN INC(score, 5) END
                    END
                END
            END
        END;
        IF n < m.p THEN INC(score, 5 * (m.p - n)) END;
        RETURN score
    END Score;
    (* graphics part *)
    PROCEDURE IntToString (x: LONGINT; VAR s: ARRAY OF CHAR);
        VAR j, k: INTEGER; a: ARRAY 32 OF CHAR;
    BEGIN
        j := 0; REPEAT a[j] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(j) UNTIL x = 0;
        k := 0; REPEAT DEC(j); s[k] := a[j]; INC(k) UNTIL j = 0;
        s[k] := 0X
    END IntToString;
    PROCEDURE DrawStringCentered (v: View; f: Ports.Frame; x, y: LONGINT; s: ARRAY OF CHAR);
    BEGIN
        f.DrawString(x - v.font.StringWidth(s) DIV 2, y + v.font.asc DIV 2, Ports.black, s, v.font)
    END DrawStringCentered;
    PROCEDURE GetCoord (v: View; i, j: INTEGER; VAR x, y: LONGINT);
        VAR w, h: LONGINT;
    BEGIN
        y := j * v.d + v.d DIV 2 + 1;
        x := i * v.d + v.d DIV 2 + 1;
        IF i = 0 THEN INC(x, v.d DIV 2)
        ELSIF i = v.mod.m+1 THEN DEC(x, v.d DIV 2)
        ELSIF j = 0 THEN INC(y, v.d DIV 2)
        ELSIF j = v.mod.m+1 THEN DEC(y, v.d DIV 2)
        END
    END GetCoord;
    (* Model *)
    PROCEDURE Init (m: Model);
    BEGIN
        m.m := para.boardSize; m.p := para.nrOfAtoms;
        NEW(m.board, m.m+2, m.m+2); NewPuzzle(m);
        m.n := 0; m.score := 0; m.showsol := FALSE
    END Init;
    PROCEDURE (m: Model) Externalize (VAR wr: Stores.Writer);
        VAR i, j: INTEGER;
    BEGIN
        m.Externalize^(wr);
        wr.WriteVersion(version);
        wr.WriteInt(m.m);
        wr.WriteInt(m.p);
        wr.WriteInt(m.n);
        wr.WriteInt(m.score);
        wr.WriteBool(m.showsol);
        FOR i := 0 TO m.m+1 DO
            FOR j := 0 TO m.m+1 DO
                wr.WriteSInt(m.board[i,j])
            END
        END
    END Externalize;
    PROCEDURE (m: Model) Internalize (VAR rd: Stores.Reader);
        VAR ver: SHORTINT; x0: LONGINT; i, j: INTEGER;
    BEGIN
        m.Internalize^(rd);
        IF ~rd.cancelled THEN
            rd.ReadVersion(version, version, ver);
            IF ~rd.cancelled THEN
                rd.ReadInt(m.m);
                rd.ReadInt(m.p);
                rd.ReadInt(m.n);
                rd.ReadInt(m.score);
                rd.ReadBool(m.showsol);
                NEW(m.board, m.m+2, m.m+2);
                FOR i := 0 TO m.m+1 DO
                    FOR j := 0 TO m.m+1 DO
                        rd.ReadSInt(m.board[i,j])
                    END
                END
            END
        END
    END Internalize;
    PROCEDURE (m: Model) CopyAllFrom (source: Models.Model);
        VAR i, j: INTEGER;
    BEGIN
        WITH source: Model DO
            Init(m);
            m.m := source.m; NEW(m.board, m.m+2, m.m+2);
            m.n := source.n; m.p := source.p;
            m.score := source.score; m.showsol := source.showsol;
            FOR i := 0 TO m.m+1 DO
                FOR j := 0 TO m.m+1 DO m.board[i,j] := source.board[i,j] END
            END
        END
    END CopyAllFrom;
    PROCEDURE (m: Model) InitFrom (source: Models.Model);
    BEGIN
        Init(m)
    END InitFrom;
    (* View *)
    PROCEDURE (v: View) Externalize (VAR wr: Stores.Writer);
        VAR i, j: INTEGER;
    BEGIN
        v.Externalize^(wr);
        wr.WriteVersion(version);
        wr.WriteInt(v.i);
        wr.WriteInt(v.j);
        wr.WriteStore(v.mod)
    END Externalize;
    PROCEDURE (v: View) Internalize (VAR rd: Stores.Reader);
        VAR ver: SHORTINT; s: Stores.Store;
    BEGIN
        v.Internalize^(rd);
        IF ~rd.cancelled THEN
            rd.ReadVersion(version, version, ver);
            IF ~rd.cancelled THEN
                rd.ReadInt(v.i);
                rd.ReadInt(v.j);
                rd.ReadStore(s); ASSERT(s # NIL, 100);
                IF s IS Model THEN
                    v.mod := s(Model)
                ELSE
                    rd.TurnIntoAlien(Stores.alienComponent)
                END;
                v.d := 0;
                v.font := NIL
            END
        END
    END Internalize;
    PROCEDURE (v: View) CopyFrom (source: Views.View);
    BEGIN
        v.CopyFrom^(source);
        WITH source: View DO
            v.i := source.i; v.j := source.j; v.d := source.d; v.font := source.font
        END
    END CopyFrom;
    PROCEDURE (v: View) InitModel (m: Models.Model);
    BEGIN
        v.mod := m(Model)
    END InitModel;
    PROCEDURE (v: View) ThisModel (): Models.Model;
    BEGIN
        RETURN v.mod
    END ThisModel;
    PROCEDURE (v: View) Restore (f: Views.Frame; l, t, r, b: LONGINT);
        VAR w, h, d, x, y, x1, y1: LONGINT; i, j: INTEGER; p: Path; s: ARRAY 16 OF CHAR;
    BEGIN
        v.context.GetSize(w, h); d := w DIV (v.mod.m + 2);
        IF (v.font = NIL) OR (v.d # d) THEN
            v.d := d; v.font := Fonts.dir.This("Chicago", d * 2 DIV 3, {}, Fonts.normal)
        END;
        FOR i := 1 TO v.mod.m+1 DO
            f.DrawLine(d, i*d,w-d, i*d, f.unit, 0);
            f.DrawLine(i*d, d, i*d,w-d, f.unit, 0)
        END;
        FOR i := 0 TO v.mod.m+1 DO
            FOR j := 0 TO v.mod.m+1 DO
                x := i * d + d DIV 2; y := j * d + d DIV 2;
                IF (i = 0) OR (i = v.mod.m+1) OR (j = 0) OR (j = v.mod.m+1) THEN
                    IF v.mod.board[i,j] = absorbed THEN DrawStringCentered(v, f, x, y, "A")
                    ELSIF v.mod.board[i,j] = reflected THEN DrawStringCentered(v, f, x, y, "R")
                    ELSIF v.mod.board[i,j] > 0 THEN
                        IntToString(v.mod.board[i,j], s); DrawStringCentered(v, f, x, y, s)
                    END
                ELSE
                    IF Marked(v.mod, i, j) THEN r := (9 * d) DIV 20;
                        f.DrawOval(x-r, y-r, x+r, y+r, Ports.fill, Ports.black)
                    END;
                    IF v.mod.showsol & Atom(v.mod, i, j) THEN r := d DIV 3;
                        IF Marked(v.mod, i, j) THEN f.DrawOval(x-r, y-r, x+r, y+r, Ports.fill, Ports.white)
                        ELSE f.DrawOval(x-r, y-r, x+r, y+r, Ports.fill, Ports.black)
                        END
                    END
                END
            END
        END;
        IF (v.i > 0) OR (v.j > 0) THEN
            GetPath(v.mod, v.i, v.j, p);
            IF p # NIL THEN
                GetCoord(v, p.i, p.j, x, y); p := p.next;
                WHILE p # NIL DO
                    GetCoord(v, p.i, p.j, x1, y1);
                    f.DrawLine(x, y, x1, y1, 2*f.unit, 0); x := x1; y := y1; p := p.next
                END
            END
        END;
        IntToString(v.mod.p, s);
        x := d; y := (v.mod.m+2)*d + (d+v.font.asc) DIV 2;
        f.DrawString(x, y, Ports.black, "Atoms: ", v.font);  x := x + v.font.StringWidth("Atoms: ");
        f.DrawString(x, y, Ports.black, s, v.font);
        IF v.mod.showsol THEN x := x + v.font.StringWidth(s);
            f.DrawString(x, y, Ports.black, "  Score: ", v.font); x := x + v.font.StringWidth("  Score: ");
            IntToString(v.mod.score, s); f.DrawString(x, y, Ports.black, s, v.font);
        END
    END Restore;
    PROCEDURE Track (v: View; f: Views.Frame; x, y: LONGINT; buttons: SET);
        VAR i, j: INTEGER; w, h: LONGINT; msg: UpdateMsg; p: Path;
    BEGIN
        i := SHORT(x DIV v.d); j := SHORT(y DIV v.d);
        IF (i > 0) & (i <= v.mod.m) & (j > 0) & (j <= v.mod.m) THEN    (* inside *)
            IF Marked(v.mod, i, j) THEN INC(v.mod.board[i,j], 4)
            ELSE DEC(v.mod.board[i,j], 4)
            END;
        ELSIF ((i = 0) OR (i = v.mod.m + 1)) & (j > 0) & (j <= v.mod.m)
        OR ((j = 0) OR (j  = v.mod.m + 1)) & (i > 0) & (i <= v.mod.m) THEN
            IF v.mod.board[i,j] = 0 THEN Shoot(v.mod, i, j) END;
            IF v.mod.showsol THEN
                IF Controllers.modify IN buttons THEN v.i := i; v.j := j ELSE v.i := 0; v.j := 0 END
            END
        END;
        Models.Broadcast(v.mod, msg)
    END Track;
    PROCEDURE (v: View) HandleModelMsg (VAR msg: Models.Message);
        VAR w, h: LONGINT;
    BEGIN
        WITH msg: UpdateMsg DO
            IF ~v.mod.showsol THEN v.i := 0; v.j := 0 END;    (* adjust view to change of model *)
            v.context.GetSize(w, h); Views.UpdateIn(v, 0, 0, w, h,  Views.keepFrames)
        ELSE
        END
    END HandleModelMsg;
    PROCEDURE (v: View) HandleCtrlMsg (f: Views.Frame; VAR msg: Controllers.Message;
                                                                                VAR focus: Views.View);
    BEGIN
        WITH msg: Controllers.TrackMsg DO
            Track(v, f, msg.x, msg.y, msg.modifiers)
        | msg: Controllers.PollOpsMsg DO
            msg.type := "ObxBlackBox.ViewDesc"
        ELSE
        END
    END HandleCtrlMsg;
    PROCEDURE (v: View) HandlePropMsg (VAR msg: Properties.Message);
    BEGIN
        WITH msg: Properties.SizePref DO
            IF (msg.w > Views.undefined) & (msg.h > Views.undefined) THEN
                Properties.ProportionalConstraint(v.mod.m, v.mod.m+1,
                                                                        msg.fixedW, msg.fixedH, msg.w, msg.h)
            ELSE
                msg.w := 100*Ports.mm; msg.h := msg.w * (v.mod.m+1) DIV v.mod.m;
            END;
        | msg: Properties.FocusPref DO
            msg.setFocus := TRUE
        ELSE
        END
    END HandlePropMsg;
    (* commands *)
    PROCEDURE Deposit*;
        VAR v: View; m: Model;
    BEGIN
        NEW(m); Init(m);
        NEW(v); v.InitModel(m);
        Views.Deposit(v)
    END Deposit;
    PROCEDURE ShowSolution*;
        VAR v : Views.View; msg: UpdateMsg;
    BEGIN
        v := Controllers.FocusView();
        IF v # NIL THEN
            WITH v: View DO
                v.mod.showsol := TRUE; v.mod.score := Score(v.mod);
                Models.Broadcast(v.mod, msg)
            END
        END
    END ShowSolution;
    PROCEDURE ShowSolutionGuard* (VAR par: Dialog.Par);
        VAR v: Views.View;
    BEGIN
        v := Controllers.FocusView();
        par.disabled := (v = NIL) OR ~(v IS View) OR v(View).mod.showsol
    END ShowSolutionGuard;
    PROCEDURE New*;
        VAR v: Views.View; msg: UpdateMsg;
    BEGIN
        v := Controllers.FocusView();
        IF v # NIL THEN
            WITH v: View DO
                NewPuzzle(v.mod);
                v.mod.n := 0; v.mod.score := 0; v.mod.showsol := FALSE;
                v.i := 0; v.j := 0;
                Models.Broadcast(v.mod, msg)
            END
        END
    END New;
    PROCEDURE Set*;
        VAR v : Views.View; msg: UpdateMsg; i, j: INTEGER;
    BEGIN
        v := Controllers.FocusView();
        IF v # NIL THEN
            WITH v: View DO v.mod.p := 0;
                FOR i := 0 TO v.mod.m + 1 DO
                    FOR j := 0 TO v.mod.m + 1 DO
                        IF Marked(v.mod, i, j) THEN INC(v.mod.p); v.mod.board[i,j] := minded
                        ELSE v.mod.board[i,j] := 0
                        END
                    END
                END;
                v.mod.n := 0; v.mod.score := 0; v.mod.showsol := FALSE;
                v.i := 0; v.j := 0;
                Models.Broadcast(v.mod, msg)
            END
        END
    END Set;
BEGIN
    seed := Kernel.Time(); para.boardSize := 8; para.nrOfAtoms := 4
END ObxBlackBox.
TextControllers.StdCtrlDesc
TextControllers.ControllerDesc
Containers.ControllerDesc
Controllers.ControllerDesc
TextRulers.StdRulerDesc
TextRulers.RulerDesc
TextRulers.StdStyleDesc
TextRulers.StyleDesc
TextRulers.AttributesDesc
Helvetica
Documents.ControllerDesc